unit upachig;

(* cpcPaChi - Un compilador de Pascal chiquitito para CPC
   Por Nacho Cabanes
   
   uPachiG - unidad "CodeGen" (generador de codigo)
   
   Versiones hasta la fecha:
   
   Num.   Fecha       Cambios
   ---------------------------------------------------
   0.17  20-Ago-2008  Algunas funciones predefinidas
                      incorporadas (ej: readkey). Generacion
                      de codigo mas modular, para permitir
                      eliminar comentarios.
                      
   0.16  17-Ago-2008  Revision general y alguna correccion
                      (ver documentacion)

   0.15  15-Ago-2008  El codigo generado para las 
                      condiciones ya es (aparentemente)
                      correcto.
                      Anadido genCPCINK para paleta de
                      colores.

   0.14  12-Ago-2008  Anadido "GenRetorno" para el retorno
                      de los PROCEDURE y "GenLlamada" para
                      saltar a ellos.
   
   0.13  09-Ago-2008  Genera codigo para WHILE, FOR, 
                      REPEAT-UNTIL (todavia no totalmente
                      correcto), y tambien para DEC.
   
   0.12  07-Ago-2008  Genera codigo para IF-THEN-ELSE
   
   0.11  05-Ago-2008  Genera codigo para etiquetas (LABEL),
                      corrige un fallo en los READ/DATA de variables
   
   0.10  25-Jun-2008  Genera codigo para variables
   
   0.06  03-Abr-2008  Incluye las ordenes PEN, PAPER, CPCMODE
   
   0.04  27-Mar-2008  Primera version del generador de codigo:
                      genera codigo para CLS, LOCATE, WRITECHAR
                      y el codigo final del cargador BASIC
                      para un codigo maquina que estara dentro
                      de ordenes DATA.
*)


interface

    
uses
  upachid;
  
  const
    volcarComentarios: boolean = true;

  var nombreFichero: string;
    
  function abrirFicheroDestino(nombre: string): boolean;
  procedure cerrarFicheroDestino;
  
  procedure genLecturaValorByte(nombre: string);
  procedure genLecturaValorInteger(nombre: string);
  
  function inversoComparacion(c: string): string;
  procedure genASIGN(nombre, valor: string);
  procedure genASIGNbyte(nombre, valor: string);
  procedure genASIGNinteger(nombre, valor: string);
  procedure genCLS;
  procedure genComentario(texto: string);
  procedure genCPCINK(tinta1, tinta2: token);
  procedure genCPCMODE;
  procedure genDEC(nombre: string; decremento: integer);
  procedure genDECbyte(nombre: string; decremento: byte);
  procedure genDECinteger(nombre: string; decremento: integer);
  procedure genGOTO(ident: string);
  procedure genDireccSinGOTO(ident: string);
  procedure genGRAPHICSPEN;
  procedure genIF(ident1: string; tipoComparacion: string; ident2: string);
  procedure genIFbyte(ident1: string; tipoComparacion: string; ident2: string);
  procedure genIFinteger(ident1: string; tipoComparacion: string; ident2: string);
  procedure genINC(nombre: string; aumento: integer);
  procedure genINCbyte(nombre: string; aumento: byte);
  procedure genINCinteger(nombre: string; aumento: integer);
  procedure genLABEL(etiqueta: string);
  procedure genLecturaFuncion(nombre: string);
  procedure genLINE(x, y: string);
  procedure genLlamada;
  procedure genLOCATE1;
  procedure genLOCATE2;
  procedure genPAPER;
  procedure genPEN;
  procedure genPLOT(x, y: string);
  procedure genREPEAT(ident1: string; tipoComparacion: string; ident2: string);
  procedure genRetorno;
  procedure genWHILE(ident1: string; tipoComparacion: string; ident2: string);
  procedure genWRITECHAR;
  procedure genWRITESTRING(texto: string);
  procedure generarCodigoFinal;
  
  function proximaDireccionLibre(tamanyo: byte): integer;
  function leerDireccionCodigoActual: integer;


implementation

uses
  upachil;

const
  lineaActual: integer = 10;
  longitudTotal: integer = 0;
  necesariaSegundaPasada: boolean = false;

  
  (* Posicion inicial del codigo resultante 
     - Se podra cambiar con un parametro *)
  posicionInicialObj = 30000;
  posicionInicialEjec: integer = posicionInicialObj + 100;  
  posicionInicialVars: integer = posicionInicialObj + 4;
  

var
  ficheroDestino: text;  
  codError: integer;

(* Comparacion inversa de una dada, para cuando haya
  que saltar en el caso contrario *)
function inversoComparacion(c: string): string;
begin
  if c = '=' then inversoComparacion := '<>' else
  if c = '<>' then inversoComparacion := '=' else
  if c = '>' then inversoComparacion := '<=' else
  if c = '<' then inversoComparacion := '>=' else
  if c = '>=' then inversoComparacion := '<' else
  if c = '<=' then inversoComparacion := '>';
end;

(* Abre el fichero de entrada. Devuelve FALSE si no se
ha podido *)
function abrirFicheroDestino(nombre: string): boolean;
begin
  assign( ficheroDestino, nombre );
  {$I-}
  rewrite( ficheroDestino );
  {$I+}

  if ioResult <> 0 then
    begin
    abrirFicheroDestino := false;
    end;
  (* Guardo el nombre para la segunda pasada *)  
  nombreFichero := nombre;
  
  (* Guardo las constantes de colores *)
  (* http://en.wikipedia.org/wiki/List_of_8-bit_computer_hardware_palettes *)
  insertarSimboloConst('BLACK','0');
  insertarSimboloConst('BLUE','1');
  insertarSimboloConst('BRIGHTBLUE','2');
  insertarSimboloConst('RED','3');
  insertarSimboloConst('MAGENTA','4');
  insertarSimboloConst('VIOLET','5');
  insertarSimboloConst('BRIGHTRED','6');
  insertarSimboloConst('PURPLE','7');
  insertarSimboloConst('BRIGHTMAGENTA','8');
  insertarSimboloConst('GREEN','9');
  insertarSimboloConst('CYAN','10');
  insertarSimboloConst('SKYBLUE','11');
  insertarSimboloConst('YELLOW','12');
  insertarSimboloConst('GREY','13');
  insertarSimboloConst('PALEBLUE','14');
  insertarSimboloConst('ORANGE','15');
  insertarSimboloConst('PINK','16');
  insertarSimboloConst('PALEMAGENTA','17');
  insertarSimboloConst('BRIGHTGREEN','18');
  insertarSimboloConst('SEAGREEN','19');
  insertarSimboloConst('BRIGHTCYAN','20');
  insertarSimboloConst('LIMEGREEN','21');
  insertarSimboloConst('PALEGREEN','22');
  insertarSimboloConst('PALECYAN','23');
  insertarSimboloConst('BRIGHTYELLOW','24');
  insertarSimboloConst('PALEYELLOW','25');
  insertarSimboloConst('WHITE','26');
  
  insertarSimboloFunc('READKEY',tBYTE);
  
  (* Codigo de salto al cuerpo del programa, por si hay proceds. *)
  {writeln( ficheroDestino, lineaActual,' DATA 3E,',
    hexStr(valorByte,2), ': '' JP, ',valorByte ,' - Comienzo de codigo');}    
    
  insertarSimboloLabel('INICIOPROGRAMA');
  genGOTO('INICIOPROGRAMA');
end;


(* Generar codigo para una orden (hasta 3 bytes) *)
procedure genCodigo(longitud: byte; byte1, byte2, byte3, comentario: string);
begin
  if (longitud > 0) or volcarComentarios then
  write( ficheroDestino, lineaActual,' ');
  if longitud >0 then 
    begin
    write( ficheroDestino, 'DATA ');
    write( ficheroDestino, byte1 );
    end;
  if longitud > 1 then
    write( ficheroDestino, ',', byte2 );
  if longitud > 2 then
    write( ficheroDestino, ',', byte3 );  
  if VolcarComentarios then
    begin
    if longitud >0 then write( ficheroDestino, ': ');
    write( ficheroDestino, ''''+comentario);
    end;
  writeln( ficheroDestino);
  lineaActual := lineaActual + 10;
  longitudTotal := longitudTotal + longitud;
end;


(* Generar codigo para la lectura del valor de un identificador 
   El valor leido se guarda en el registro A *)
procedure genLecturaValorByte(nombre: string);
var 
  valorByte: byte;
  direccion: integer;
  tipoSimbolo: byte;
begin
  if nombre[1] in ['0'..'9'] then
    begin
    (* Si es numero *)
    val(nombre,valorByte,codError);
    if codError <> 0 then errorFatal('Error en el valor numerico');
    genCodigo(2, '3E', hexStr(valorByte,2), '', 'LD A, '+nombre);
    end
  else
    begin
    tipoSimbolo := leerSimboloTS(nombre);
    if tipoSimbolo = tCONST then
      (* Si es constante con nombre *)
      begin
      valorByte := leerSimboloConst(nombre);
      genCodigo(2, '3E', hexStr(valorByte,2), '', 'LD A, '+nombre);
      end
    else if tipoSimbolo = tVAR then
      (* Si es variable *)
      begin
      direccion := leerSimboloVar(nombre);
      genCodigo(3, '3A', hexStr(direccion mod 256,2),
        hexStr(direccion div 256,2), 
        'LD A, (Variable '+nombre+')');
      end
    else if tipoSimbolo = tFUNC then
     (* Si es funcion *)
      begin
      genLecturaFuncion(nombre);
      end
    else errorFatal('Tipo de datos incorrecto');
    end;
end;


(* Generar codigo para la lectura del valor de un identificador 
   El valor leido se guarda en el registro HL *)
procedure genLecturaValorInteger(nombre: string);
var 
  valorInteger: integer;
  direccion: integer;
  tipoSimbolo,tipoDato: byte;
begin
  if nombre[1] in ['0'..'9'] then
    begin
    (* Si es numero *)
    val(nombre,valorInteger,codError);
    if codError <> 0 then errorFatal('Error en el valor numerico');
    genCodigo(3, '21', hexStr(valorInteger mod 256,2), 
      hexStr(valorInteger div 256,2), 'LD HL, '+nombre);
    end
  else
    begin
    tipoSimbolo := leerSimboloTS(nombre);
    if tipoSimbolo = tCONST then
      (* Si es constante con nombre *)
      begin
      valorInteger := leerSimboloConst(nombre);
      genCodigo(3, '21', hexStr(valorInteger mod 256,2), 
      hexStr(valorInteger div 256,2), 'LD HL, '+nombre);
      end
    else if tipoSimbolo = tVAR then
      (* Si es variable *)
      begin
      direccion := leerSimboloVar(nombre);
      tipoDato := leerTipoDatoTS(nombre);
      if tipoDato = tINTEGER then
        begin
        genCodigo(3, '2A', hexStr(direccion mod 256,2),
          hexStr(direccion div 256,2), 
          'LD HL, (Variable '+nombre+')');
        end
      else if tipoDato = tBYTE then
        begin
        genCodigo(3, '3A', hexStr(direccion mod 256,2),
          hexStr(direccion div 256,2), 
          'LD A, (Variable '+nombre+')');
        genCodigo(3, '6F', '26', '00', ' A->HL: LD L, A - LD H, 0' );
        end
      else errorFatal('Tipo de datos incorrecto!');
      end
    else if tipoSimbolo = tFUNC then
     (* Si es funcion *)
      begin
      (* ## Provisional ## *)
      genLecturaFuncion(nombre);      
      end
    else errorFatal('Tipo de datos incorrecto');
    end;
end;

procedure genASIGN(nombre, valor: string);
begin
  if validarByteNombre(nombre) and validarByteNombre(valor) then
    genASIGNbyte(nombre, valor)
  else
    genASIGNinteger(nombre, valor);
end;

(* Generar codigo para una asignacion *)
procedure genASIGNbyte(nombre, valor: string);
var
  valorByte: byte;
  tipoSimbolo: byte;
  direccion: integer;
begin
  genLecturaValorByte(valor);
  direccion := leerSimboloVar(nombre);
  genCodigo(3, '32', hexStr(direccion mod 256,2),
    hexStr(direccion div 256,2), 
    'LD ('+nombre+'), A');
end;

procedure genASIGNinteger(nombre, valor: string);
var
  valorByte: byte;
  tipoSimbolo: byte;
  direccion: integer;
begin
  genLecturaValorInteger(valor);
  direccion := leerSimboloVar(nombre);
  genCodigo(3, '22', hexStr(direccion mod 256,2),
    hexStr(direccion div 256,2), 
    'LD ('+nombre+'), HL');
end;


(* Generar codigo para CLS *)
procedure genCLS;
begin
  genCodigo(3, 'CD', '6C', 'BB', 'CALL &BB6C - CLS' );
end;

(* Generar Comentario en codigo destino *)
procedure genComentario(texto: string);
begin
  genCodigo(0, '', '', '', texto);
end;

(* Generar codigo para CpcInk -tinta- *)
procedure genCPCINK(tinta1, tinta2: token);
var
  valorByte: byte;
begin
  if tinta1.tipo = tkENTERO then
    val(tinta1.valor,valorByte,codError)
  else
    valorByte := leerSimboloConst(tinta1.valor);
  genCodigo(2, '06', hexStr(valorByte,2), '', 
    ' LD B, '+tinta1.valor);

  if tinta2.tipo = tkENTERO then
    val(tinta2.valor,valorByte,codError)
  else
    valorByte := leerSimboloConst(tinta2.valor);
  genCodigo(2, '0E', hexStr(valorByte,2), '', 
    ' LD C, '+tinta2.valor);
  
  genCodigo(3, 'CD', '32', 'BC', 'CALL &BC32 - SET INK' );
end;


procedure genDEC(nombre: string; decremento: integer);
begin
  if validarByteNombre(nombre) and (decremento>0) and (decremento<255) then
    genDECbyte(nombre, decremento)
  else
    genDECinteger(nombre, decremento);
end;


(* Generar codigo para decremento *)
procedure genDECbyte(nombre: string; decremento: byte);
var
  direccion: integer;
  i: byte;
begin
  (* Posiblemente seria mas razonable usar INC (HL) -34h*)  
  direccion := leerSimboloVar(nombre);
  genCodigo(3, '3A', hexStr(direccion mod 256,2),
    hexStr(direccion div 256,2),
    'LD A, (Variable '+nombre+')');
  
  (* Seria mas eficiente usar SUB si el valor es grande ## *)
  for i:=1 to decremento do
    begin
    genCodigo(1, '3D', '', '' ,' DEC A' );
    end;
  
  genCodigo(3, '32', hexStr(direccion mod 256,2),
    hexStr(direccion div 256,2),
    'LD ('+nombre+'), A');
end;

procedure genDECinteger(nombre: string; decremento: integer);
var
  direccion: integer;
  i: byte;
begin
  (* Posiblemente seria mas razonable usar INC (HL) -34h*)  
  direccion := leerSimboloVar(nombre);
  genCodigo(3, '2A', hexStr(direccion mod 256,2),
    hexStr(direccion div 256,2),
    'LD HL, (Variable '+nombre+')');
  
  (* Seria mas eficiente usar SUB si el valor es grande ## *)
  for i:=1 to decremento do
    begin
    genCodigo(1, '2B', '', '' ,' DEC HL' );
    end;
  
  genCodigo(3, '22', hexStr(direccion mod 256,2),
    hexStr(direccion div 256,2),
    'LD ('+nombre+'), HL');
end;


(* Generar codigo para GOTO *)
procedure genGOTO(ident: string);
var
  direccion: integer;
begin
  direccion := leerSimboloLabel(ident);
  if direccion <> 0 then
    genCodigo(3, 'C3', hexStr(direccion mod 256,2),
      hexStr(direccion div 256,2), 'JP '+ident)
  else
    begin
    genCodigo(3, 'C3',
      'nnn'+ident+'LO,',
      'nnn'+ident+'HI', ' JP '+ident);
    necesariaSegundaPasada := true;  
    end;
end;

(* Generar codigo para la direccion de salto de un GOTO,
pero sin el goto -para saltos condicionales- *)
procedure genDireccSinGOTO(ident: string);
var
  direccion: integer;
begin
  direccion := leerSimboloLabel(ident);
  if direccion <> 0 then
    genCodigo(2, hexStr(direccion mod 256,2),
      hexStr(direccion div 256,2), '', ident)
  else
    begin
    genCodigo(2, 'nnn'+ident+'LO,', 'nnn'+ident+'HI', '', ident);
    necesariaSegundaPasada := true;  
    end;
end;

procedure genGRAPHICSPEN;
begin
  genCodigo(3, 'CD', 'DE', 'BB', 'CALL &BBDE - SET GRAPHICS PEN' );
end;


(* Generar codigo para comparacion IF *) (* #### Solo byte por ahora ###*)
procedure genIF(ident1: string; 
  tipoComparacion: string; ident2: string);
begin
  if validarByteNombre(ident1) and validarByteNombre(ident2) then
    genIFbyte(ident1, tipoComparacion, ident2)
  else
    genIFinteger(ident1, tipoComparacion, ident2);
end;

(* Generar codigo para comparacion IF *) (* #### Solo byte por ahora ###*)
procedure genIFbyte(ident1: string; 
  tipoComparacion: string; ident2: string);
var
  direccion: integer;
  i: byte;
  identAux: string;
begin
  (* Caso especial: si es <= invierto para convertir en >= *)
  if tipoComparacion = '<=' then
    begin
    identAux := ident1;
    ident1 := ident2;
    ident2 := identAux;
    tipoComparacion := '>=';
    end;
  (* Caso especial: si es > invierto para convertir en >= *)
  if tipoComparacion = '>' then
    begin
    identAux := ident1;
    ident1 := ident2;
    ident2 := identAux;
    tipoComparacion := '<';
    end;
  (* Primero guardo ident2 en B *)
  genComentario(' IF '+ident1+tipoComparacion+ident2);
  genLecturaValorByte(ident2);
  genCodigo(1, '47', '', '', ' LD B, A ('+ident2+')' );

  (* Luego guardo ident1 en A *)
  genLecturaValorByte(ident1);

  (* Ahora preparo la comparacion -inversa, porque salto al ELSE-*)
  genCodigo(1, 'B8', '', '', ' CP B' );
  if tipoComparacion = '=' then
    genCodigo(1, 'C2', '', '', ' JP NZ' )
  else if tipoComparacion = '<>' then
    genCodigo(1, 'CA', '', '', ' JP Z' )
  {else if tipoComparacion = '>' then
    writeln( ficheroDestino, lineaActual,' DATA FA:'' JP M' )}
  else if tipoComparacion = '>=' then 
    genCodigo(1, 'DA', '', '', ' JP C' )
  else if tipoComparacion = '<' then
    genCodigo(1, 'F2', '', '', ' JP P' )
  else
    errorFatal('Comparacion incorrecta');
  necesariaSegundaPasada := true;
end;


(* Generar codigo para comparacion IF *) (* #### Version para integer ###*)
procedure genIFinteger(ident1: string; 
  tipoComparacion: string; ident2: string);
var
  direccion: integer;
  i: byte;
  identAux: string;
begin
  (* Caso especial: si es <= invierto para convertir en >= *)
  if tipoComparacion = '<=' then
    begin
    identAux := ident1;
    ident1 := ident2;
    ident2 := identAux;
    tipoComparacion := '>=';
    end;
  (* Caso especial: si es > invierto para convertir en >= *)
  if tipoComparacion = '>' then
    begin
    identAux := ident1;
    ident1 := ident2;
    ident2 := identAux;
    tipoComparacion := '<';
    end;
  (* Primero guardo ident2 en DE *)
  genComentario(' IF '+ident1+tipoComparacion+ident2);
  
  (* Compruebo si uno de los datos es BYTE, y convierto *)
  if validarByteNombre(ident2) then
    begin
    genLecturaValorByte(ident2);
    genCodigo(3, '6F', '26', '00', ' A->HL: LD L, A - LD H, 0' ); 
    end
  else
    genLecturaValorInteger(ident2);
    
  (* Como no existe LD DE, HL, uso la pila: PUSH HL y POP DE *)
  genCodigo(2, 'E5', 'D1', '', ' DE=HL: PUSH HL - POP DE ('+ident2+')' ); 

  (* Luego guardo ident1 en HL *)
  (* Compruebo si es BYTE, y convierto *)
  if validarByteNombre(ident1) then
    begin
    genLecturaValorByte(ident1);
    genCodigo(3, '6F', '26', '00', ' A->HL: LD L, A - LD H, 0' ); 
    end
  else
    genLecturaValorInteger(ident1);

  (* Ahora preparo la comparacion -inversa, porque salto al ELSE- *)
  genCodigo(3, 'A7','ED', '52', ' AND A - SBC HL, DE' );
  if tipoComparacion = '=' then
    genCodigo(1, 'C2', '', '', ' JP NZ' )
  else if tipoComparacion = '<>' then
    genCodigo(1, 'CA', '', '', ' JP Z' )
  {else if tipoComparacion = '>' then
    writeln( ficheroDestino, lineaActual,' DATA FA:'' JP M' )}
  else if tipoComparacion = '>=' then 
    genCodigo(1, 'DA', '', '', ' JP C' )
  else if tipoComparacion = '<' then
    genCodigo(1, 'F2', '', '', ' JP P' )
  else
    errorFatal('Comparacion incorrecta');
  necesariaSegundaPasada := true;
end;

procedure genINC(nombre: string; aumento: integer);
begin
  if validarByteNombre(nombre) and (aumento>0) and (aumento<255) then
    genINCbyte(nombre, aumento)
  else
    genINCinteger(nombre, aumento);
end;


(* Generar codigo para incremento *)
procedure genINCbyte(nombre: string; aumento: byte);
var
  direccion: integer;
  i: byte;
begin
  (* Posiblemente seria mas razonable usar INC (HL) -34h*)  
  (* Posiblemente seria mas razonable usar INC (HL) -34h*)  
  direccion := leerSimboloVar(nombre);
  genCodigo(3, '3A', hexStr(direccion mod 256,2),
    hexStr(direccion div 256,2),
    'LD A, (Variable '+nombre+')');
  
  (* Seria mas eficiente usar ADD si el valor es grande ## *)
  for i:=1 to aumento do
    begin
    genCodigo(1, '3C', '', '' ,' INC A' );
    end;
  
  genCodigo(3, '32', hexStr(direccion mod 256,2),
    hexStr(direccion div 256,2),
    'LD ('+nombre+'), A');
end;

procedure genINCinteger(nombre: string; aumento: integer);
var
  direccion: integer;
  i: byte;
begin
  (* Posiblemente seria mas razonable usar INC (HL) -34h*)  
  direccion := leerSimboloVar(nombre);
  genCodigo(3, '2A', hexStr(direccion mod 256,2),
    hexStr(direccion div 256,2),
    'LD HL, (Variable '+nombre+')');
  
  (* Seria mas eficiente usar ADD si el valor es grande ## *)
  for i:=1 to aumento do
    begin
    genCodigo(1, '23', '', '' ,' INC HL' );
    end;
  
  genCodigo(3, '22', hexStr(direccion mod 256,2),
    hexStr(direccion div 256,2),
    'LD ('+nombre+'), HL');
end;


(* Generar codigo para LABEL *)
procedure genLABEL(etiqueta: string);
var
  direccionCadena: string;
begin
  genComentario(' Etiqueta de salto: '+etiqueta);
  {writeln( ficheroDestino, lineaActual,' '' Etiqueta de salto: ',etiqueta);}
  str(leerDireccionCodigoActual, direccionCadena);
  insertarDireccionLabel(etiqueta, direccionCadena);
  lineaActual := lineaActual + 10;
end;

(* Generar codigo para llamada a funciones habituales *)
procedure genLecturaFuncion(nombre: string);
begin
  if nombre = 'READKEY' then 
    begin
    genCodigo(3, 'CD', '18', 'BB', 'CALL &BB18 - READKEY' );
    end
  else if nombre = 'KEYPRESSED' then 
    begin
    genCodigo(3, 'CD', '1B', 'BB', 'CALL &BB1B - KEYPRESSED' );
    genCodigo(1, 'D8', '', '', 'RET C' );
    genCodigo(3, '3E', '00', 'C9', 'LD A,0 - RET' );
    end
  {else if nombre = 'TESTKEY' then 
    begin
    (* Falta leer el parametro *)
    writeln( ficheroDestino, lineaActual,' DATA CD, 1E, BB: '' CALL &BB1E - TESTKEY' );
    lineaActual := lineaActual + 10;
    writeln( ficheroDestino, lineaActual,' DATA 3E,01: '' LD A, 1' );
    lineaActual := lineaActual + 10;
    writeln( ficheroDestino, lineaActual,' DATA CD, 18, BB: '' RET NZ' );
    lineaActual := lineaActual + 10;
    writeln( ficheroDestino, lineaActual,' DATA CD, 18, BB: '' LD A, 0' );
    lineaActual := lineaActual + 10;
    writeln( ficheroDestino, lineaActual,' DATA CD, 18, BB: '' RET Z' );
    lineaActual := lineaActual + 10;
    longitudTotal := longitudTotal + 3;
    end}
  else if nombre = 'SCRHPOS' then 
    begin
    genCodigo(3, 'CD', '78', 'BB', 'CALL &BB78 - GET CURSOR' );
    genCodigo(1, '7C', '', '', 'LD A, H (HPOS)' );
    end
  else if nombre = 'SCRVPOS' then 
    begin
    genCodigo(3, 'CD', '78', 'BB', 'CALL &BB78 - GET CURSOR' );
    genCodigo(1, '7D', '', '', 'LD A, L (VPOS)' );
    end
  else if nombre = 'SCRREADCHAR' then 
    begin
    genCodigo(3, 'CD', '60', 'BB', 'CALL &BB60 - SCR READ CHAR' );
    end
  else 
    errorFatal('Funcion desconocida');
end;


(* Generar codigo para llamada a una subrutina -sin direccion- *)
procedure genLlamada;
begin
  genCodigo(1, 'CD', '', '', 'CALL - Llamada a proced.' );
end;


(* Generar codigo para LOCATE *)
procedure genLOCATE1;
begin
  genCodigo(3, 'CD', '6F', 'BB', 'CALL &BB6F - CURSOR COLUMN' );
end;
procedure genLOCATE2;
begin
  genCodigo(3, 'CD', '72', 'BB', 'CALL &BB72 - CURSOR ROW' );
end;


(* Generar codigo para CPCMODE *)
procedure genCPCMODE;
begin
  genCodigo(3, 'CD', '0E', 'BC', 'CALL &BC0E - SET MODE' );
end;


procedure genLectura2Integer(x, y: string);
begin
  genLecturaValorInteger(x);
  (* Como no existe LD DE, HL, uso la pila: PUSH HL y POP DE *)
  genCodigo(2, 'E5', 'D1', '', ' DE=HL: PUSH HL - POP DE ('+x+')' ); 
  genLecturaValorInteger(y);
end;


(* Generar codigo para PLOT -punto grafico- *)
procedure genPLOT(x, y: string);
begin
  genLectura2Integer(x, y);
  genCodigo(3, 'CD', 'EA', 'BB', 'CALL &BBEA - PLOT ABSOLUTE' );
end;

(* Generar codigo para LINE -linea grafica- *)
procedure genLINE(x, y: string);
begin
  genLectura2Integer(x, y);
  genCodigo(3, 'CD', 'F6', 'BB', 'CALL &BBF6 - LINE ABSOLUTE' );
end;

(* Generar codigo para PAPER *)
procedure genPAPER;
begin
  genCodigo(3, 'CD', '96', 'BB', 'CALL &BB96 - SET PAPER' );
end;

(* Generar codigo para PEN *)
procedure genPEN;
begin
  genCodigo(3, 'CD', '90', 'BB', 'CALL &BB90 - SET PEN' );
end;

(* Generar codigo para REPEAT *)
procedure genREPEAT(ident1: string; 
  tipoComparacion: string; ident2: string);
begin
  genComentario('REPEAT UNTIL '+ident1+tipoComparacion+ident2 );
  genIF(ident1,tipoComparacion,ident2 );
end;

(* Generar codigo de retorno tras un procedimiento *)
procedure genRetorno;
begin
  genCodigo(1, 'C9', '', '', 'RET - Retorno de proced.' );
end;

(* Generar codigo para WRITECHAR *)
procedure genWHILE(ident1: string; 
  tipoComparacion: string; ident2: string);
begin
  genComentario('WHILE '+ident1+tipoComparacion+ident2 );
  genIF(ident1,tipoComparacion,ident2 );
end;


(* Generar codigo para WRITECHAR *)
procedure genWRITECHAR;
begin
  genCodigo(3, 'CD', '5A', 'BB', 'CALL &BB5A - WRITECHAR' );
end;

procedure genWRITESTRING(texto: string);
var 
  i: byte;
  direccionCadena: string;
begin
  genComentario('-- Escritura de cadena');
  insertarSimboloLabel('txt'+Texto);
  insertarSimboloLabel('saltoIni'+Texto);
  insertarSimboloLabel('saltoRep'+Texto);
  insertarSimboloLabel('fin'+Texto);
  
  genGOTO('saltoIni'+Texto);
  genLabel('txt'+Texto);
  (* Datos de la cadena *)
  write( ficheroDestino, lineaActual,' DATA ');
  for i:= 1 to length(texto) do
    write( ficheroDestino, hexStr(ord(texto[i]),2), ',');
  writeln( ficheroDestino, '00: ''Texto: ', texto);  
  lineaActual := lineaActual + 10;
  longitudTotal := longitudTotal + length(texto) + 1;
  
  (* Rutina repetitiva de escritura *)
  genLabel('saltoIni'+Texto);
  genCodigo(1, '11', '', '', 'LD DE, texto' );
  genDireccSinGOTO('txt'+Texto);
  
  genLabel('saltoRep'+Texto);
  genCodigo(3, '1A', 'B7', 'CA', 'LD A, (DE) - OR A - JP Z (Salir)' );
  genDireccSinGOTO('fin'+Texto);    
  genWriteChar;
  genCodigo(1, '13', '', '', 'INC DE - Sgte caracter' );  
  genGOTO('saltoRep'+Texto);  
  genLabel('fin'+Texto);
  genComentario('-- Fin de escritura de cadena');
end;

(* Cerrar fichero de destino (al final de la generacion) *)
procedure cerrarFicheroDestino;
begin
  close(ficheroDestino);
end;

function proximaDireccionLibre(tamanyo: byte): integer;
begin
  proximaDireccionLibre := posicionInicialVars;
  inc(posicionInicialVars, tamanyo);
end;

function leerDireccionCodigoActual: integer;
begin
  leerDireccionCodigoActual := posicionInicialEjec+longitudTotal;
end;

(* Segunda pasada: si hay saltos adelante, a direcciones indeterminadas *)
procedure segundaPasada;
var
  i,posicion, direccion, codError: integer;
  destinoRevisado: text;
  nuevoNombre, linea, linea2: string;  
begin    
  nuevoNombre := copy(nombreFichero,1,length(nombreFichero)-4)
    + '2.bas';
  assign( destinoRevisado, nuevoNombre );
  {$I-}
  reset( ficheroDestino );
  rewrite( destinoRevisado );
  {$I+}
  while not eof(ficheroDestino) do
    begin
    readln( ficheroDestino, linea);
    (* Reviso si hay cadenas a sustituir *)
    for i:=1 to numSimbolos do
      begin
      {writeln('Resvisando: nnn',listaSimbolos[i].nombre,'=', upcase(linea));}
      posicion := pos('NNN'+listaSimbolos[i].nombre+'LO', upcase(linea));
      if posicion > 0 then
        begin
        linea2 := copy(linea,1,posicion-1);
        val(listaSimbolos[i].valorDir, direccion, codError);
        linea2 := linea2 + hexStr(direccion mod 256,2)+ ','+
        hexStr(direccion div 256,2)+':'' JP '+listaSimbolos[i].nombre;
        (* Falta analisis #####*)
        linea := linea2;
        end;
      end;
    writeln( destinoRevisado, linea);
    end;
  close( ficheroDestino );
  close( destinoRevisado );
end;


(* Genera el codigo de destino final: cargador Basic *)
procedure generarCodigoFinal;
begin
  append( ficheroDestino );
  writeln( ficheroDestino, lineaActual,' DATA C9: '' RET' );
  writeln( ficheroDestino, lineaActual+10,' longitud = ',longitudTotal );
  writeln( ficheroDestino, lineaActual+20,' MEMORY ', posicionInicialObj-1 );
  writeln( ficheroDestino, lineaActual+30,' ''Codigo del programa' );
  writeln( ficheroDestino, lineaActual+40,' FOR n=',posicionInicialEjec,
    ' TO ',posicionInicialEjec,'+longitud' );
  writeln( ficheroDestino, lineaActual+50,'   READ a$:POKE n,VAL("&"+a$)' );
  writeln( ficheroDestino, lineaActual+60,' NEXT' );
  writeln( ficheroDestino, lineaActual+70,' ''Espacio para variables');
  writeln( ficheroDestino, lineaActual+80,' FOR n=',posicionInicialObj,
    ' TO ',posicionInicialEjec-1 );
  writeln( ficheroDestino, lineaActual+90,'   POKE n,0' );
  writeln( ficheroDestino, lineaActual+100,' NEXT' );
  writeln( ficheroDestino, lineaActual+110,' CALL ',posicionInicialObj );
  cerrarFicheroDestino;
  if necesariaSegundaPasada then
    segundaPasada;
end;


begin
end.
